Attribute VB_Name = "Module2"

Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Public Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Public Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long

Private Declare Function WaitForSingleObject Lib "kernel32" _
    (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwAccess As _
    Long, ByVal fInherit As Integer, ByVal hObjects As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" _
    (ByVal hObject As Long) As Long

Public Function GetTypeDescription(TypeCode As String) As String
    Dim sql As String
    Dim rs As New ADODB.Recordset
    sql = "Select des from typelist where name like '" & TypeCode & "'"
    Set rs = adoConnection.Execute(sql)
    GetTypeDescription = ""
    If Not rs.EOF Then
        GetTypeDescription = GetFieldValue(rs(0))
    End If
    rs.Close
    Set rs = Nothing
End Function

Public Function GetContentHTML(ByVal Filename As String) As Boolean
    Dim strLine As String
    Dim strContent As String
    If Dir(Filename) = "" Then
    GetContentHTML = False
        Exit Function
    End If
    Open Filename For Input As #1
        strContent = ""
        Open Filename & ".temp" For Output As #2
            Do While Not EOF(1)
                Line Input #1, strLine
                If InStr(1, strLine, "<frame src=""" & UCase(Left(Right(Filename, 8), 4)) & "_files/tabstrip.htm"" name=""frTabs"" marginwidth=0 marginheight=0>", vbTextCompare) > 0 Then
                
                Else
                    'strContent = strContent & vbCrLf & strLine
                    Print #2, strLine
                End If
            Loop
        Close #1
    Close #2
    'FileSystem.Kill Filename
    'FileCopy Filename & ".temp", Filename
    GetContentHTML = True
End Function


Function WaitForProcess(taskId As Long, Optional msecs As Long = -1) As Boolean
    Dim procHandle As Long
    procHandle = OpenProcess(&H100000, True, taskId)
    WaitForProcess = WaitForSingleObject(procHandle, msecs) <> -1
    CloseHandle procHandle
End Function

Public Function SetAllTextbox2Lock(ByRef Form1 As Form, Status As Boolean)
    Dim e As Control
    For Each e In Form1.Controls
        If (TypeOf e Is TextBox) Or (TypeOf e Is ComboBox) Then
            e.Locked = Status
        End If
    Next
End Function

Public Function isBackupNow(strLastdateBackup As String) As Boolean
    Dim mm, dd, yy As String
    Dim strMMMDDYYYY As String
    Dim numberDayAgoBackup As Integer
    Dim date1 As Date
    Dim date2 As Date
    
    strMMMDDYYYY = Trim(strLastdateBackup)
    If Trim(strMMMDDYYYY) = "" Then
        isBackupNow = True
        Exit Function
    End If
    date1 = CDate(strMMMDDYYYY)
    'mm = Month("01/" & Left(strMMMDDYYYY, 3) & "/2008")
    'yy = Right(strMMMDDYYYY, 2)
    'dd = Mid("November, 20 2008", InStr(1, "November, 20 2008", ", ", vbTextCompare) + 2, 2)
    ''numberDayAgoBackup = Format(Date, "MMDDYY") - Format(mm & dd & yy, "MMDDYY")
    'date1.Day = Day(Date)
    'date1.Month = Month(Date)
    'date1.Year = Year(Date)
    '
    'date2.Day = Val(dd)
    'date2.Month = Val(mm)
    'date2.Year = Val(yy)
    numberDayAgoBackup = Date - date1
    If numberDayAgoBackup >= Val(getSettingValue("backupeveryday")) Then
        isBackupNow = True
    Else
        isBackupNow = False
    End If
End Function
Public Function ReplaceSetting(FindWhat As String, ReplaceBy As String) As Boolean
    Dim arr(10) As String
    Dim I As Integer
    arr(1) = getSettingValue("OFFICE")
    arr(2) = getSettingValue("enabledbackup")
    arr(3) = getSettingValue("lastbackup")
    arr(4) = getSettingValue("backupeveryday")
    arr(5) = getSettingValue("backupto")
    arr(6) = getSettingValue("Autobackup")
    
    Select Case FindWhat
        Case "OFFICE"
            arr(1) = ReplaceBy
        Case "enabledbackup"
            arr(2) = ReplaceBy
        Case "lastbackup"
            arr(3) = ReplaceBy
        Case "backupeveryday"
            arr(4) = ReplaceBy
        Case "backupto"
            arr(5) = ReplaceBy
        Case "Autobackup"
            arr(6) = ReplaceBy
    End Select
    
    Open App.Path & "\setting.ini" For Output As #1
        Print #1, "OFFICE=" & arr(1)
        Print #1, "enabledbackup=" & arr(2)
        Print #1, "lastbackup=" & arr(3)
        Print #1, "backupeveryday=" & arr(4)
        Print #1, "backupto=" & arr(5)
        Print #1, "Autobackup=" & arr(6)
    Close #1
    ReplaceSetting = True
End Function

Public Function BrowseForFolder(hwndOwner As Long, sPrompt As String) As String
    'declare variables to be used
    Dim iNull As Integer
    Dim lpIDList As Long
    Dim lResult As Long
    Dim sPath As String
    Dim udtBI As BrowseInfo
    
    'initialise variables
    With udtBI
        .hwndOwner = hwndOwner
        .lpszTitle = lstrcat(sPrompt, "")
        .ulFlags = BIF_RETURNONLYFSDIRS
    End With
    
    'Call the browse for folder API
    lpIDList = SHBrowseForFolder(udtBI)
    
    'get the resulting string path
    If lpIDList Then
        sPath = String$(MAX_PATH, 0)
        lResult = SHGetPathFromIDList(lpIDList, sPath)
        Call CoTaskMemFree(lpIDList)
        iNull = InStr(sPath, vbNullChar)
        If iNull Then sPath = Left$(sPath, iNull - 1)
    End If
    
    'If cancel was pressed, sPath = ""
    BrowseForFolder = sPath
End Function

Public Function getSettingValue(strWhat As String) As String
    Dim strLine As String
    Dim returnValue As String
    Open App.Path & "\setting.ini" For Input As #1
        returnValue = ""
        Do While Not EOF(1)
            Line Input #1, strLine
            If InStr(1, UCase(strLine), UCase(strWhat), vbTextCompare) > 0 Then
                returnValue = Right(strLine, Len(strLine) - Len(strWhat))
            End If
        Loop
    Close #1
    getSettingValue = Replace(returnValue, "=", "")
End Function

'Backupdata by copy file db.mdb to file .dat and call ZipFile to zip with winrar
Public Function BackupData() As Boolean
    Dim strSaveTo As String
    If getSettingValue("backupto") <> "" Then
        strSaveTo = getSettingValue("backupto")
        If Right(strSaveTo, 1) = "/" Or Right(strSaveTo, 1) = "\" Then
            strSaveTo = Left(strSaveTo, Len(strSaveTo) - 1)
        End If
    Else
        MsgBox "You have to config backup setting!", vbInformation + vbOKOnly, "Backup"
        Exit Function
    End If
    
    If Len(Dir$(strSaveTo, vbDirectory)) = 0 Then
        MsgBox "Could not find save path, please check the path in backup setting", vbInformation + vbOKOnly, "Path not found"
        Exit Function
    End If
    
    If GetAutoticketingDBPath = "" Then
        Call CopyFile(App.Path & "\db.mdb", strSaveTo & "\Backup_for_" & getOffice & "_Rundate" & Day(Date) & Left(MonthName(Month(Date)), 3) & Year(Date) & ".dat", 1)
    Else
        'Call FileCopy(GetAutoticketingDBPath, strSaveTo & "\Backup_for_" & getOffice & "_Rundate" & Day(Date) & Left(MonthName(Month(Date)), 3) & Year(Date) & ".dat")
        Call CopyFile(GetAutoticketingDBPath, strSaveTo & "\Backup_for_" & getOffice & "_Rundate" & Day(Date) & Left(MonthName(Month(Date)), 3) & Year(Date) & ".dat", 1)
    End If
    Call ReplaceSetting("lastbackup", MonthName(Month(Date)) & ", " & Day(Date) & " " & Year(Date))
    Call ZipFile(strSaveTo & "\Backup_for_" & getOffice & "_Rundate" & Day(Date) & Left(MonthName(Month(Date)), 3) & Year(Date) & ".dat", "", True, " a -ep ", False, "")
    'Call CompactRepairAccessDB(strSaveTo & "\Backup_for_" & getOffice & "_Rundate" & Day(Date) & Left(MonthName(Month(Date)), 3) & Year(Date) & ".dat")
    
    BackupData = True
End Function


'=====================================================================================
'COMPACT AND REPAIR DATABASE WITH PASSWORD PROTECTION IF PROVIDED
'=====================================================================================
'    Call CompactRepairAccessDB(MyDatabasePathAndFile, MyPassword)
Public Sub CompactRepairAccessDB(ByVal sDBFILE As String, Optional sPassword As String = "")
    'Dim sDBPATH As String, sDBNAME As String, sDB As String, sDBtmp As String
    '
    'sDBNAME = sDBFILE 'extrapulate the file name
    'Do While InStr(1, sDBNAME, "\") > 0
    '        sDBNAME = Right(sDBNAME, Len(sDBNAME) - InStr(1, sDBNAME, "\"))
    'Loop
    ''get the path name only
    'sDBPATH = Left(sDBFILE, Len(sDBFILE) - Len(sDBNAME))
    '
    'sDB = sDBPATH & sDBNAME
    'sDBtmp = sDBPATH & "tmp" & sDBNAME
    '
    ''Call the statement to execute compact and repair...
    'If sPASSWORD > "" Then
    '        Call DBEngine.CompactDatabase(sDB, sDBtmp, dbLangGeneral, , ";pwd=" & sPASSWORD)
    'Else
    '
    '        Call DBEngine.CompactDatabase(sDB, sDBtmp)
    'End If
    ''wait for the app to finish
    '        DoEvents
    ''remove the uncompressed original
    '        Kill sDB
    ''rename the compressed file to the original to restore for other functions
    '        Name sDBtmp As sDB
End Sub


Public Function ZipFile(ByVal PathSource As String, ByVal PathDes As String, ByVal IsDel As Boolean, _
        ByVal CommandWinRar As String, _
        ByVal IsPass As Boolean, ByVal Pass As String) As Boolean

    Dim strShell As String
    Dim PathWinRAR As String
    'Dim a As New clsCompress
    Dim waiting As Boolean
    Dim idProcess
    Dim isCompressed As Boolean
    
    Dim removePathSource_Dat As String
    removePathSource_Dat = Replace(PathSource, ".dat", "")
    
    'PathWinRAR = "C:\Program Files\WinRAR\rar.exe"
    PathWinRAR = App.Path & "\rar.exe"
    isCompressed = False
    If Dir(PathWinRAR) <> "" Then
        If CommandWinRar = " a -ep " Then
            strShell = CommandWinRar
            If IsPass Then strShell = strShell & " -p" & Pass
            strShell = strShell & removePathSource_Dat & ".rar"
            
            strShell = strShell & " " & PathSource
        Else
            strShell = CommandWinRar
            If IsPass Then strShell = strShell & " -p" & Pass
            strShell = strShell & removePathSource_Dat
            
            strShell = strShell & " " & PathDes

        End If
            
        If Dir(removePathSource_Dat & ".rar") <> "" Then
            FileSystem.Kill (removePathSource_Dat & ".rar")
        End If
        
        'and here it is how I use it...
        WaitForProcess Shell(PathWinRAR & strShell, vbHide)
        isCompressed = True
        'idProcess = Shell(PathWinRAR & strShell, vbHide)
    Else
        MsgBox "You have to install winrar programme before backup, the backup file will be with small size accordingly", vbCritical + vbOKOnly, "Compress"
        'a.Compress PathSource, PathSource & ".z"
    End If
    'waiting = True
    'If IsDel = True Then
    '    While waiting
    '        If Dir(PathSource & ".rar") <> "" Then
    '            DoEvents
    '            Sleep 2000
    '            FileSystem.Kill (PathSource)
    '            waiting = False
    '
    '
    '        End If
    '        Debug.Print idProcess
    '
    '       ' MousePointerSettings.flexArrow
    '    Wend
    'End If
    If isCompressed Then
        FileSystem.Kill (PathSource)
    End If
    ZipFile = True
End Function

Function CloseWindow(ByVal partialWindowCaption$)
    Dim Whnd&, L&, Nam$
    
    partialWindowCaption = LCase$(partialWindowCaption)
    Whnd = GetWindow(MDIForm1.hwnd, GW_HWNDFIRST)
    
    Do While Whnd <> 0
        If IsWindow(Whnd) Then
            L = GetWindowTextLength(Whnd)
            If L > 0 Then
                Nam = Space$(L + 1)
                L = GetWindowText(Whnd, Nam, L + 1)
                Nam = LCase$(Left$(Nam, Len(Nam) - 1))
                If InStr(Nam, partialWindowCaption) Then
                    EndTask Whnd, True, True
                    Exit Do
                End If
            End If
        End If
        Whnd = GetWindow(Whnd, GW_HWNDNEXT)
        DoEvents
    Loop
End Function

Public Function DetectExcel()
    KillProcess "excel"
End Function

Public Sub KillProcess(ByVal processName As String)
    On Error GoTo ErrHandler
    Dim oWMI
    Dim ret
    Dim sService
    Dim oWMIServices
    Dim oWMIService
    Dim oServices
    Dim oService
    Dim servicename
    
    Set oWMI = GetObject("winmgmts:")
    Set oServices = oWMI.InstancesOf("win32_process")
    
    For Each oService In oServices
        serviceame = LCase(Trim(CStr(oService.Name) & ""))
        If InStr(1, serviceame, LCase(processName), vbTextCompare) > 0 Then
            ret = oService.Terminate
        End If
    Next
    Set oServices = Nothing
    Set oWMI = Nothing
ErrHandler:
    err.Clear
End Sub




